home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 1_2002.ISO / Data / Zips / VERY VERY 187924242001.psc / cPicture24.cls < prev    next >
Encoding:
Visual Basic class definition  |  2001-04-24  |  10.9 KB  |  336 lines
  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4.   Persistable = 0  'NotPersistable
  5.   DataBindingBehavior = 0  'vbNone
  6.   DataSourceBehavior  = 0  'vbNone
  7.   MTSTransactionMode  = 0  'NotAnMTSObject
  8. END
  9. Attribute VB_Name = "cPicture24"
  10. Attribute VB_GlobalNameSpace = False
  11. Attribute VB_Creatable = True
  12. Attribute VB_PredeclaredId = False
  13. Attribute VB_Exposed = False
  14. Option Explicit
  15.  
  16. Public hDC As Long
  17. Public hBitmap As Long
  18. Public pBits As Long
  19. Public lSize As Long
  20. Public lWidth As Long
  21. Public lHeight As Long
  22.  
  23. ' types
  24. Private Type BITMAP
  25.     bmType As Long
  26.     bmWidth As Long
  27.     bmHeight As Long
  28.     bmWidthBytes As Long
  29.     bmPlanes As Integer
  30.     bmBitsPixel As Integer
  31.     bmBits As Long
  32. End Type
  33. Private Type RECT
  34.     Left As Long
  35.     Top As Long
  36.     Right As Long
  37.     Bottom As Long
  38. End Type
  39. Private Type BITMAPFILEHEADER
  40.    bfType As Integer
  41.    bfSize As Long
  42.    bfReserved1 As Integer
  43.    bfReserved2 As Integer
  44.    bfOffBits As Long
  45. End Type
  46. Private Type BITMAPINFOHEADER
  47.    biSize As Long
  48.    biWidth As Long
  49.    biHeight As Long
  50.    biPlanes As Integer
  51.    biBitCount As Integer
  52.    biCompression As Long
  53.    biSizeImage As Long
  54.    biXPelsPerMeter As Long
  55.    biYPelsPerMeter As Long
  56.    biClrUsed As Long
  57.    biClrImportant As Long
  58. End Type
  59. Private Type BITMAPINFO_24
  60.    bmiHeader As BITMAPINFOHEADER
  61. End Type
  62. Private Type RGBQUAD
  63.         rgbBlue As Byte
  64.         rgbGreen As Byte
  65.         rgbRed As Byte
  66.         rgbReserved As Byte
  67. End Type
  68. Private Type BITMAPINFO
  69.         bmiHeader As BITMAPINFOHEADER
  70.         bmiColors As RGBQUAD
  71. End Type
  72.  
  73. ' constants
  74. Private Const DIB_RGB_COLORS = 0
  75.  
  76. ' win32 api function declarations
  77. Private Declare Function VarPtr Lib "msvbvm50.dll" (Ptr As Any) As Long
  78. Private Declare Function VarPtrArray Lib "msvbvm50.dll" Alias "VarPtr" (Ptr() As Any) As Long
  79. Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlCopyMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As Long)
  80. Private Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As Long)
  81. Private Declare Sub ZeroMemory Lib "kernel32.dll" Alias "RtlZeroMemory" (Destination As Any, ByVal Length As Long)
  82. Private Declare Sub FillMemory Lib "kernel32.dll" Alias "RtlFillMemory" (dest As Any, ByVal numBytes As Long, Fill As Byte)
  83. Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
  84. Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
  85. Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
  86. Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
  87. Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
  88. Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
  89. Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
  90. Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
  91. Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
  92. Private Declare Function SetDIBits_24 Lib "gdi32" Alias "SetDIBits" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpbi As BITMAPINFO_24, ByVal wUsage As Long) As Long
  93. Private Declare Function CreateBitmap Lib "gdi32" (ByVal nWidth As Long, ByVal nHeight As Long, ByVal nPlanes As Long, ByVal nBitCount As Long, lpBits As Any) As Long
  94. Private Declare Function SetBkColor Lib "gdi32" (ByVal hDC As Long, ByVal crColor As Long) As Long
  95. Private Declare Function GetBkColor Lib "gdi32" (ByVal hDC As Long) As Long
  96. Private Declare Function Rectangle Lib "gdi32" (ByVal hDC As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
  97. Private Declare Function CreateDIBSection Lib "gdi32" (ByVal hDC As Long, pBitmapInfo As BITMAPINFO, ByVal un As Long, ByRef lplpVoid As Long, ByVal Handle As Long, ByVal dw As Long) As Long
  98. Private Declare Function SaveDC Lib "gdi32" (ByVal hDC As Long) As Long
  99. Private Declare Function RestoreDC Lib "gdi32" (ByVal hDC As Long, ByVal nSavedDC As Long) As Long
  100. Private Declare Function SetTextColor Lib "gdi32" (ByVal hDC As Long, ByVal crColor As Long) As Long
  101. Private Declare Function SetTextAlign Lib "gdi32" (ByVal hDC As Long, ByVal wFlags As Long) As Long
  102. Private Declare Function GetTextAlign Lib "gdi32" (ByVal hDC As Long) As Long
  103. Private Declare Function GetTextColor Lib "gdi32" (ByVal hDC As Long) As Long
  104. Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hDC As Long, ByVal X As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
  105.  
  106.  
  107.  
  108. ' init to a blank bitmap of specified size
  109. Function Init(Optional Width As Long, Optional Height As Long) As Boolean
  110. On Error Resume Next
  111. Dim Info As BITMAPINFO
  112. Dim DisplayDC As Long
  113.     CleanUp
  114.     ' fill bitmap info structure
  115.     With Info.bmiHeader
  116.         .biBitCount = 24
  117.         .biWidth = Width
  118.         .biHeight = Height
  119.         .biPlanes = 1
  120.         .biSize = Len(Info.bmiHeader)
  121.     End With
  122.     ' get a handle to the display
  123.     DisplayDC = GetDC(0)
  124.     ' create a dc compatible with the display
  125.     hDC = CreateCompatibleDC(DisplayDC)
  126.     SaveDC hDC
  127.     If hDC = 0 Then GoTo InitFailed ' check we received a valid handle
  128.     ' create a device independant bitmap
  129.     hBitmap = CreateDIBSection(hDC, Info, DIB_RGB_COLORS, pBits, 0, 0)
  130.     If hBitmap = 0 Then GoTo InitFailed ' check we received a valid handle
  131.     ' use the bitmap for the dc
  132.     SelectObject hDC, hBitmap
  133.     ' clean up the display dc
  134.     ReleaseDC 0, DisplayDC
  135.     ' compute size
  136.     lWidth = Width
  137.     lHeight = Height
  138.     lSize = lWidth * lHeight * 3
  139.     Init = True
  140.     Exit Function
  141. InitFailed:
  142. End Function
  143.  
  144.  
  145.  
  146. ' init from a bitmap file
  147. Function InitFromFile(FileName As String) As Boolean
  148. Dim Info As BITMAPINFO
  149. Dim f As Integer
  150. Dim DisplayDC As Long
  151. Dim FileHead As BITMAPFILEHEADER
  152. Dim bmpInfo_24 As BITMAPINFO_24
  153. Dim bmpInfoHeader As BITMAPINFOHEADER
  154. Dim picBytes() As Byte
  155. Dim picOffset As Long, picLen As Long
  156. On Error Resume Next
  157.     ' open the file and read the header info
  158.     picOffset = 1
  159.     picLen = FileLen(FileName)
  160.     f = FreeFile
  161.     Open FileName For Binary Access Read As #f
  162.     Get #f, picOffset, FileHead
  163.     Get #f, picOffset + 14, bmpInfoHeader
  164.     ' check the bpp (bits per pixel)
  165.     Select Case bmpInfoHeader.biBitCount
  166.         Case 24
  167.             Get #f, picOffset + 14, bmpInfo_24
  168.         Case Else
  169.             GoTo InitFailed ' other formats unsupported
  170.     End Select
  171.     ' get each byte of the picture
  172.     ReDim picBytes(0 To picLen - 44)
  173.     Get #f, , picBytes
  174.     ' close file
  175.     Close #f
  176.     ' get a handle to the display
  177.     DisplayDC = GetDC(0)
  178.     ' create a new dc that is compatible with the display
  179.     hDC = CreateCompatibleDC(DisplayDC)
  180.     ' create a dc that is compatible with the display, and the size of the bitmap
  181. '    hBitmap = CreateCompatibleBitmap(DisplayDC, bmpInfoHeader.biWidth, bmpInfoHeader.biHeight)
  182.     ' fill bitmap info structure
  183.     With Info.bmiHeader
  184.         .biBitCount = bmpInfoHeader.biBitCount
  185.         .biWidth = bmpInfoHeader.biWidth
  186.         .biHeight = bmpInfoHeader.biHeight
  187.         .biPlanes = bmpInfoHeader.biPlanes
  188.         .biSize = Len(Info.bmiHeader)
  189.     End With
  190.     ' create a device independant bitmap
  191.     hBitmap = CreateDIBSection(hDC, Info, DIB_RGB_COLORS, pBits, 0, 0)
  192.     '
  193.     SelectObject hDC, hBitmap
  194.     ' set the bits of the bitmap to the temporary array
  195.     SetDIBits_24 hDC, hBitmap, 0, bmpInfoHeader.biHeight, picBytes(0), bmpInfo_24, 0
  196.     ' clean up the display dc
  197.     ReleaseDC 0, DisplayDC
  198.     ' compute size
  199.     lWidth = bmpInfoHeader.biWidth
  200.     lHeight = bmpInfoHeader.biHeight
  201.     lSize = lWidth * lHeight * 3
  202.     InitFromFile = True
  203.     Exit Function
  204. InitFailed:
  205. End Function
  206.  
  207.  
  208.  
  209. ' sets an individual pixel to the specified red, green and blue values
  210. Function SetPixel(X As Long, y As Long, r As Byte, g As Byte, b As Byte)
  211. On Error Resume Next
  212. Dim p As Long
  213.     p = pBits + (y * lWidth + X) * 3
  214.     CopyMemory ByVal p, ByVal VarPtr(b), 1
  215.     p = p + 1
  216.     CopyMemory ByVal p, ByVal VarPtr(g), 1
  217.     p = p + 1
  218.     CopyMemory ByVal p, ByVal VarPtr(r), 1
  219. End Function
  220. ' gets the red, green and blue of an individual pixel
  221. Sub GetPixel(X As Long, y As Long, r As Byte, g As Byte, b As Byte)
  222. On Error Resume Next
  223. Dim p As Long
  224.     p = pBits + (y * lWidth + X) * 3
  225.     CopyMemory ByVal VarPtr(b), ByVal p, 1
  226.     p = p + 1
  227.     CopyMemory ByVal VarPtr(g), ByVal p, 1
  228.     p = p + 1
  229.     CopyMemory ByVal VarPtr(r), ByVal p, 1
  230. End Sub
  231. ' gets an individual pixel in long format
  232. Function GetPixelLong(X As Long, y As Long) As Long
  233. On Error Resume Next
  234. Dim p As Long
  235. Dim r As Byte
  236. Dim g As Byte
  237. Dim b As Byte
  238.     p = pBits + (y * lWidth + X) * 3
  239.     CopyMemory ByVal VarPtr(b), ByVal p, 1
  240.     p = p + 1
  241.     CopyMemory ByVal VarPtr(g), ByVal p, 1
  242.     p = p + 1
  243.     CopyMemory ByVal VarPtr(r), ByVal p, 1
  244.     GetPixelLong = RGB(r, g, b)
  245. End Function
  246.  
  247.  
  248.  
  249. ' clearing functions
  250. Sub ClearToBlack()
  251.     ZeroMemory ByVal pBits, lSize
  252. End Sub
  253. Sub ClearToGrey(Shade As Byte)
  254.     FillMemory ByVal pBits, lSize, ByVal Shade
  255. End Sub
  256. Sub Clear(r As Byte, g As Byte, b As Byte)
  257. Dim p As Long
  258. Dim p2 As Long
  259. Dim pr As Long
  260. Dim pg As Long
  261. Dim pb As Long
  262.     p = pBits
  263.     p2 = pBits + lSize
  264.     pr = VarPtr(r)
  265.     pg = VarPtr(g)
  266.     pb = VarPtr(b)
  267.     Do
  268.         CopyMemory ByVal p, ByVal pb, 1
  269.         p = p + 1
  270.         CopyMemory ByVal p, ByVal pg, 1
  271.         p = p + 1
  272.         CopyMemory ByVal p, ByVal pr, 1
  273.         p = p + 1
  274.     Loop Until p > p2
  275. End Sub
  276.  
  277.  
  278.  
  279. ' prints some text onto the picture
  280. Sub PrintText(str As String, Optional X As Long = 0, Optional y As Long = 0)
  281.     TextOut hDC, X, y, str, Len(str)
  282. End Sub
  283.  
  284.  
  285.  
  286. ' background color
  287. Property Get Backcolor() As Long
  288.     Backcolor = GetBkColor(hDC)
  289. End Property
  290. Property Let Backcolor(Color As Long)
  291.     SetBkColor hDC, Color
  292. End Property
  293.  
  294.  
  295.  
  296. ' text color
  297. Property Get TextColor() As Long
  298.     TextColor = GetTextColor(hDC)
  299. End Property
  300. Property Let TextColor(Color As Long)
  301.     SetTextColor hDC, Color
  302. End Property
  303.  
  304.  
  305.  
  306. ' text alignment
  307. Property Get TextAlign() As Long
  308.     TextAlign = GetTextAlign(hDC)
  309. End Property
  310. Property Let TextAlign(Align As Long)
  311.     SetTextAlign hDC, Align
  312. End Property
  313.  
  314.  
  315.  
  316. ' shows the picture on the screen
  317. Sub Show()
  318.     BitBlt GetDC(0), 0, 0, lWidth, lHeight, hDC, 0, 0, vbSrcCopy
  319. End Sub
  320.  
  321.  
  322.  
  323. ' deallocate resources
  324. Sub CleanUp()
  325. On Error Resume Next
  326.     ' delete bitmap
  327.     DeleteObject hBitmap
  328.     ' delete dc
  329.     RestoreDC hDC, -1
  330.     DeleteDC hDC
  331. End Sub
  332. Private Sub Class_Terminate()
  333.     CleanUp
  334. End Sub
  335.  
  336.